home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 011 / autodesk.arc / TUBE.LSP < prev   
Encoding:
Text File  |  1987-04-29  |  4.1 KB  |  173 lines
  1. ;*************************************************************************
  2.  
  3. ;                              TUBE.LSP
  4.  
  5. ;      By Simon Jones    Autodesk Ltd, London     March 1987
  6.  
  7. ;   This macro will draw an open tube in any orientation, made up
  8. ; of 3DFACES.
  9.  
  10. ;*************************************************************************
  11.  
  12. (vmon)
  13. (prompt "\nLoading. Please wait...")
  14. (terpri)
  15.  
  16. (defun MODES (a)
  17.    (setq MLST '())
  18.    (repeat (length a)
  19.       (setq MLST (append MLST (list (list (car a) (getvar (car a))))))
  20.       (setq a (cdr a)))
  21. )
  22.  
  23. (defun MODER ()
  24.    (repeat (length MLST)
  25.       (setvar (caar MLST) (cadar MLST))
  26.       (setq MLST (cdr MLST))
  27.    )
  28. )
  29.  
  30. (defun *ERROR* (st)
  31.   (moder)
  32.   (terpri)
  33.   (princ "\nError: ")
  34.   (princ st)
  35.   (princ)
  36. )
  37.  
  38.  
  39. ; Convert degrees to radians
  40. (defun DTR (a)
  41.   (* pi (/ a 180.0))
  42. )
  43.  
  44. ; Convert radians to degrees
  45. (defun RTD (a)
  46.   (/ (* a 180.0) pi)
  47. )
  48.  
  49. ; List of X an Y co-ordinates of point
  50. (defun XY (pt)
  51.   (list (car pt) (cadr pt))
  52. )
  53.  
  54. ; List of X and Z co-ordinates of point
  55. (defun XZ (pt)
  56.   (list (car pt) (caddr pt))
  57. )
  58.  
  59. ;*********** ROTATE POINTS ABOUT Y-AXIS ******************
  60.  
  61. (defun ABT-Y (pt a / p)
  62.    (setq p (polar (xz cen)
  63.                      (+ (angle (xz cen) (xz pt)) a)
  64.                      (distance (xz cen) (xz pt))
  65.               )
  66.    )
  67.    (list (car p) (cadr pt) (cadr p))
  68. )
  69.  
  70. ;*********** ROTATE POINTS ABOUT Z-AXIS ******************
  71.  
  72. (defun ABT-Z (pt a)
  73.    (append
  74.          (polar cen
  75.                (+ (angle cen pt) a)
  76.                (distance cen pt)
  77.          )
  78.          (list (caddr pt))
  79.    )
  80. )
  81.  
  82. ;******************** MAIN PROGRAM ************************
  83.  
  84. (defun C:TUBE ( / p1 p2 ay az c ang len dzz dxy
  85.                   ang1 n r cen2 vc vb cen l)
  86.  
  87.    (modes '("blipmode" "cmdecho"))
  88.    (setvar "CMDECHO" 0)
  89.    (command "UNDO" "MARK")
  90.  
  91.    (initget (+ 1 8 16))
  92.    (setq cen (getpoint "\nFrom point: "))
  93.  
  94.    (initget (+ 1 8 16))
  95.    (setq cen2 (getpoint cen "\nTo point: "))
  96.  
  97.    (initget (+ 1 2 4) "Diameter")
  98.    (setq r (getdist cen "\nDiameter/<Radius>: "))
  99.    (if (= r "Diameter")
  100.        (progn
  101.          (initget (+ 1 2 4))
  102.          (setq r (/ (getdist cen "\nDiameter: ") 2.0))
  103.        )
  104.    )
  105.  
  106.    (initget (+ 2 4))
  107.    (setq n (getint "\nNumber of faces <10>: "))
  108.    (if (null n) (setq n 10))
  109.  
  110.    (setq ang1 (/ (* 2 pi) n)) ;Angle per segment
  111.    (setq dxy (distance cen cen2))
  112.    (setq dzz (- (caddr cen2) (caddr cen)))
  113.    (setq len (sqrt (+ (* dzz dzz) (* dxy dxy))))
  114.  
  115.    (setq ang 0 c 0 l nil)
  116.    (setq az (angle (xy cen) (xy cen2)))
  117.    (setq ay (atan dzz dxy))
  118.  
  119.    (terpri)
  120.    (while (< c (1+ n))
  121.  
  122.         ; Calculate pair of points for horizontal tube
  123.         (setq p1 (list
  124.                      (car cen)
  125.                      (+ (* r (cos ang)) (cadr cen))
  126.                      (+ (* r (sin ang)) (caddr cen))
  127.                   )
  128.         )
  129.         (setq p2 (list
  130.                      (+ len (car cen))
  131.                      (+ (* r (cos ang)) (cadr cen))
  132.                      (+ (* r (sin ang)) (caddr cen))
  133.                   )
  134.         )
  135.  
  136.         ; Rotate points perpendicular to Y-axis
  137.         (setq p1 (abt-y p1 ay))
  138.         (setq p2 (abt-y p2 ay))
  139.  
  140.         ; Rotate points perpendicular to Z-axis
  141.         (setq p1 (abt-z p1 az))
  142.         (setq p2 (abt-z p2 az))
  143.  
  144.         ; Construct a list containing all the points of the
  145.         ; tube in the correct order for the "3DFACE" command
  146.         (if (= (rem (+ c 1) 2) 1)
  147.             (progn
  148.               (setq l (append l (list p1)))
  149.               (setq l (append l (list p2)))
  150.             )
  151.             (progn
  152.               (setq l (append l (list p2)))
  153.               (setq l (append l (list p1)))
  154.             )
  155.         )
  156.  
  157.         ; Increment angle
  158.         (setq ang (+ ang ang1))
  159.  
  160.         (princ "\rGenerating faces - ") (princ c)
  161.         (setq c (1+ c))
  162.    )
  163.  
  164.    ; Draw "tube"
  165.    (setvar "BLIPMODE" 0)
  166.    (command "3DFACE")         ; Enter 3DFACE command and
  167.    (foreach n l (command n))  ; Pass over each 3d point
  168.    (command "")
  169.  
  170.    (moder)
  171.    (princ)
  172. )
  173.